home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
8bitfiles.net/archives
/
archives.tar
/
archives
/
compuserve-file-archive
/
05 Programming
/
LISP2.TXT
< prev
next >
Wrap
Text File
|
2019-04-13
|
15KB
|
477 lines
PROGRAM LISP;
LABEL 101, 102;
CONST MAXNODE = 1000;
TYPE
INPUTSYMBOL = (ATOM, PERIOD, LPAREN, RPAREN);
RWORDS = (RHSYM, RTSYM, HEADSYM, TAILSYM, EQSYM, QUOTESYM,
ATOMSYM, CONDSYM, LABELSYM, LAMBDASYM, COPYSYM, APPENDSYM, CONCSYM,
CONSSYM);
STATUSTYPE = (UNMARKED, LEFT, RIGHT, MARKED);
SYMBEXPPTR = ^SYMBOLICEXPRESSION;
ALFA = PACKED ARRAY [1 .. 10] OF CHAR;
SYMBOLICEXPRESSION = RECORD
STATUS : STATUSTYPE;
NEXT : SYMBEXPPTR;
CASE ANATOM : BOOLEAN OF
TRUE : (NAME : ALFA;
CASE ISARESERVEDWORD : BOOLEAN OF
TRUE : (RESSYM : RWORDS));
FALSE : (HEAD, TAIL : SYMBEXPPTR)
END;
VAR
LOOKAHEADSYM, SYM : INPUTSYMBOL ;
ID : ALFA;
ALREADYPEEKED : BOOLEAN ;
CH : CHAR ;
PTR : SYMBEXPPTR;
FREELIST, NODELIST, ALIST : SYMBEXPPTR;
NILNODE, TNODE : SYMBOLICEXPRESSION;
RESWORD : RWORDS;
RESERVED : BOOLEAN ;
RESWORDS : ARRAY [RWORDS] OF ALFA;
FREENODES : INTEGER;
NUMBEROFGCS : INTEGER;
PROCEDURE GARBAGEMAN;
PROCEDURE MARK(VAR LIST : SYMBEXPPTR);
VAR FATHER, SON, CURRENT : SYMBEXPPTR;
BEGIN
FATHER := NIL; CURRENT := LIST; SON := CURRENT;
WHILE CURRENT <> NIL DO
WITH CURRENT^ DO
CASE STATUS OF
UNMARKED:
IF ANATOM THEN STATUS := MARKED
ELSE IF (HEAD^.STATUS <> UNMARKED) OR (HEAD = CURRENT)
THEN
IF (TAIL^.STATUS <> UNMARKED) OR (TAIL = CURRENT)
THEN STATUS := MARKED
ELSE
BEGIN
STATUS := RIGHT; SON := TAIL; TAIL := FATHER;
FATHER := CURRENT; CURRENT := SON
END
ELSE
BEGIN
STATUS := LEFT; SON := HEAD; HEAD := FATHER;
FATHER := CURRENT; CURRENT := SON
END;
LEFT :
IF TAIL^.STATUS <> UNMARKED THEN
BEGIN
STATUS := MARKED; FATHER := HEAD; HEAD := SON;
SON := CURRENT
END
ELSE
BEGIN
STATUS := RIGHT; CURRENT := TAIL; TAIL := HEAD;
HEAD := SON; SON := CURRENT
END;
RIGHT:
BEGIN
STATUS := MARKED; FATHER := TAIL; TAIL := SON;
SON := CURRENT
END;
MARKED : CURRENT := FATHER
END
END;
PROCEDURE COLLECTFREENODES;
VAR TEMP : SYMBEXPPTR;
BEGIN
WRITE(' NUMBER OF NODES BEFORE COLLECTION = ', FREENODES:1, '.');
FREELIST := NIL; FREENODES := 0; TEMP := NODELIST;
WHILE TEMP <> NIL DO
BEGIN
IF TEMP^.STATUS <> UNMARKED THEN TEMP^.STATUS := UNMARKED
ELSE
BEGIN
FREENODES := FREENODES + 1; TEMP^.HEAD := FREELIST;
FREELIST := TEMP
END;
TEMP := TEMP^.NEXT
END;
WRITELN(' NUMBER OF FREENODES AFTER COLLECTION = ',FREENODES:1,'.')
END;
BEGIN
NUMBEROFGCS := NUMBEROFGCS + 1; WRITELN;
WRITELN('GARBAGE COLLECTION.'); WRITELN; MARK(ALIST);
IF PTR <> NIL THEN MARK(PTR); COLLECTFREENODES
END;
PROCEDURE POP(VAR SPTR : SYMBEXPPTR);
BEGIN
IF FREELIST = NIL THEN
BEGIN
WRITELN('NOT ENOUGH SPACE TO EVALUATE THE EXPRESSION');
GOTO 102
END;
FREENODES := FREENODES - 1; SPTR := FREELIST;
FREELIST := FREELIST^.HEAD
END;
PROCEDURE ERROR(NUMBERS : INTEGER);
BEGIN
WRITELN; WRITE('eRROR ',NUMBERS:1,',');
CASE NUMBERS OF
1 : WRITELN(' ATOM OR ( EXPECTED IN THE S-EXPR.');
2 : WRITELN(' ATOM, (, OR ) EXPECTED IN THE S-EXPR.');
3 : WRITELN(' LABEL AND LAMBDA ARE NOT NAMES OF FUNCTIONS.');
4 : WRITELN(') EXPECTED IN THE S-EXPR.');
5 : WRITELN('1ST ARGUMENT OF REPLACEH IS AN ATOM.');
6 : WRITELN('1ST ARGUMENT OF REPLACET IS AN ATOM.');
7 : WRITELN('ARGUMENT OF HEAD IS AN ATOM.');
8 : WRITELN('ARGUMENT OF TAIL IS AN ATOM.');
9 : WRITELN('1ST ARGUMENT OF APPEND IS NOT A LIST.');
10 : WRITELN(' , OR ) EXPECTED IN CONCATENATE.');
11 : WRITELN('END OF FILE ENCOUNTERED BEFORE A "FIN" CARD.');
12 : WRITELN('LAMBDA OR LABEL EXPECTED.')
END;
IF NUMBERS IN [11] THEN GOTO 102 ELSE GOTO 101
END;
PROCEDURE BACKINPUT;
BEGIN
ALREADYPEEKED := TRUE; LOOKAHEAD := SYM; SYM := LPAREN
END;
PROCEDURE NEXTSYM;
VAR I : INTEGER;
BEGIN
IF ALREADYPEEKED
THEN BEGIN SYM := LOOKAHEADSYM; ALREADYPEEKED := FALSE END
ELSE
BEGIN
WHILE CH = ' ' DO
BEGIN IF EOLN THEN WRITELN; READ(CH);
END;
IF CH IN ['(','.',')']
THEN
BEGIN
CASE CH OF
'(': SYM := LPAREN;
'.': SYM := PERIOD;
')': SYM := RPAREN;
END;
IF EOLN THEN WRITELN; READ(CH);
END
ELSE
BEGIN
SYM := ATOM; ID := ' '; I := 0;
REPEAT
I := I + 1; IF I<11 THEN ID[I] := CH;
IF EOLN THEN WRITELN; READ(CH)
UNTIL CH IN [' ','(','.',')'];
RESWORD := RHSYM;
WHILE (ID <> RESWORDS[RESWORD]) AND (RESWORD <> CONSSYM) DO
RESWORD := SUCC(RESWORD);
RESERVED := ID = RESWORDS[RESWORD]
END
END
END;
PROCEDURE READEXPR(VAR SPTR : SYMBEXPPTR);
VAR NXT : SYMBEXPPTR;
BEGIN
POP(SPTR); NXT := SPTR^.NEXT;
CASE SYM OF
RPAREN, PERIOD : ERROR(1);
ATOM:
WITH SPTR^ DO
BEGIN
ANATOM := TRUE; NAME := ID; ISARESERVEDWORD := RESERVED;
IF RESERVED THEN RESSYM := RESWORD
END;
LPAREN:
WITH SPTR^ DO
BEGIN
NEXTSYM;
IF SYM = PERIOD THEN ERROR(2)
ELSE
IF SYM = RPAREN THEN SPTR^ := NILNODE
ELSE
BEGIN
ANATOM := FALSE; READEXPR(HEAD); NEXTSYM;
IF SYM = PERIOD
THEN
BEGIN
NEXTSYM; READEXPR(TAIL); NEXTSYM;
IF SYM <> RPAREN THEN ERROR(4)
END
ELSE
BEGIN
BACKINPUT; READEXPR(TAIL)
END
END
END
END;
SPTR^.NEXT := NXT
END;
PROCEDURE PRINTNAME(VAR NAME : ALFA);
VAR I : INTEGER;
BEGIN
I := 1;
REPEAT
WRITE(NAME[I]);
I := I + 1;
UNTIL (NAME[I] = ' ') OR (I = 11);
WRITE(' ')
END;
PROCEDURE PRINTEXPR(SPTR : SYMBEXPPTR);
LABEL 103;
BEGIN
IF SPTR^.ANATOM THEN PRINTNAME(SPTR^.NAME)
ELSE
BEGIN
WRITE('(');
103: WITH SPTR^ DO
BEGIN
PRINTEXPR(HEAD);
IF TAIL^.ANATOM AND (TAIL^.NAME = 'NIL ')
THEN WRITE(')')
ELSE
IF TAIL^.ANATOM
THEN
BEGIN WRITE('.');PRINTEXPR(TAIL); WRITE(')') END
ELSE BEGIN SPTR := TAIL; GOTO 103 END
END
END
END;
FUNCTION EVAL(E, ALIST : SYMBEXPPTR) : SYMBEXPPTR;
VAR TEMP, CAROFE, CAAROFE : SYMBEXPPTR;
FUNCTION REPLACEH(SPTR1, SPTR2 : SYMBEXPPTR) : SYMBEXPPTR;
BEGIN
IF SPTR1^.ANATOM THEN ERROR(5) ELSE SPTR1^.HEAD := SPTR2;
REPLACEH := SPTR1
END;
FUNCTION REPLACET(SPTR1, SPTR2 : SYMBEXPPTR) : SYMBEXPPTR;
BEGIN
IF SPTR1^.ANATOM THEN ERROR(6) ELSE SPTR1^.TAIL := SPTR2;
REPLACET := SPTR1
END;
FUNCTION HEAD(SPTR : SYMBEXPPTR) : SYMBEXPPTR;
BEGIN
IF SPTR^.ANATOM THEN ERROR(7) ELSE HEAD := SPTR^.HEAD
END;
FUNCTION TAIL(SPTR : SYMBEXPPTR) : SYMBEXPPTR;
BEGIN
IF SPTR^.ANATOM THEN ERROR(8) ELSE TAIL := SPTR^.TAIL
END;
FUNCTION CONS(SPTR1, SPTR2 : SYMBEXPPTR) : SYMBEXPPTR;
VAR TEMP : SYMBEXPPTR;
BEGIN
POP(TEMP); TEMP^.ANATOM := FALSE; TEMP^.HEAD := SPTR1;
TEMP^.TAIL := SPTR2; CONS := TEMP;
END;
FUNCTION COPY(SPTR : SYMBEXPPTR) : SYMBEXPPTR;
VAR TEMP, NXT : SYMBEXPPTR;
BEGIN
IF SPTR^.ANATOM
THEN
BEGIN
POP(TEMP); NXT := TEMP^.NEXT; TEMP := SPTR;
TEMP^.NEXT := NXT; COPY := TEMP
END
ELSE COPY := CONS(COPY(SPTR^.HEAD),COPY(SPTR^.TAIL))
END;
FUNCTION APPEND(SPTR1, SPTR2 : SYMBEXPPTR) : SYMBEXPPTR;
BEGIN
IF SPTR1^.ANATOM
THEN
IF SPTR1^.NAME <> 'NIL ' THEN ERROR(9)
ELSE APPEND := SPTR2
ELSE
APPEND := CONS(COPY(SPTR1^.HEAD),APPEND(SPTR1^.TAIL,SPTR2))
END;
FUNCTION CONC(SPTR1 : SYMBEXPPTR) : SYMBEXPPTR;
VAR SPTR2, NILPTR : SYMBEXPPTR;
BEGIN
IF SYM <> RPAREN
THEN
BEGIN
NEXTSYM; READEXPR(SPTR2); NEXTSYM;
CONC := CONS(SPTR1,CONC(SPTR2));
END
ELSE
IF SYM = RPAREN
THEN
BEGIN
NEW(NILPTR);
WITH NILPTR^ DO
BEGIN ANATOM := TRUE; NAME := 'NIL ' END;
CONC := CONS(SPTR1, NILPTR)
END
ELSE ERROR(10)
END;
FUNCTION EQQ(SPTR1, SPTR2 : SYMBEXPPTR) : SYMBEXPPTR;
VAR TEMP, NXT : SYMBEXPPTR;
BEGIN
POP(TEMP); NXT := TEMP^.NEXT;
IF SPTR1^.ANATOM AND SPTR2^.ANATOM
THEN
IF SPTR1^.NAME = SPTR2^.NAME THEN TEMP^ := TNODE
ELSE TEMP^ := NILNODE
ELSE
IF SPTR1 = SPTR2 THEN TEMP^ := TNODE
ELSE TEMP^ := NILNODE;
TEMP^.NEXT := NXT; EQQ := TEMP
END;
FUNCTION ATOM(SPTR : SYMBEXPPTR) : SYMBEXPPTR;
VAR TEMP, NXT : SYMBEXPPTR;
BEGIN
POP(TEMP); NXT := TEMP^.NEXT;
IF SPTR^.ANATOM THEN TEMP^ := TNODE ELSE TEMP^ := NILNODE;
TEMP^.NEXT := NXT; ATOM := TEMP
END;
FUNCTION LOOKUP(KEY, ALIST : SYMBEXPPTR) : SYMBEXPPTR;
VAR TEMP : SYMBEXPPTR;
BEGIN
TEMP := EQQ(HEAD(HEAD(ALIST)),KEY);
IF TEMP^.NAME = 'T ' THEN LOOKUP := TAIL(HEAD(ALIST))
ELSE LOOKUP := LOOKUP(KEY,TAIL(ALIST))
END;
FUNCTION BINDARGS(NAMES, VALUES : SYMBEXPPTR) : SYMBEXPPTR;
VAR TEMP, TEMP2 : SYMBEXPPTR;
BEGIN
IF NAMES^.ANATOM AND (NAMES^.NAME = 'NIL ')
THEN BINDARGS := ALIST
ELSE
BEGIN
TEMP := CONS(HEAD(NAMES),EVAL(HEAD(VALUES),ALIST));
TEMP2 := BINDARGS(TAIL(NAMES),TAIL(VALUES));
BINDARGS := CONS(TEMP,TEMP2)
END
END;
FUNCTION EVCON(CONDPAIRS : SYMBEXPPTR) : SYMBEXPPTR;
VAR TEMP : SYMBEXPPTR;
BEGIN
TEMP := EVAL(HEAD(HEAD(CONDPAIRS)),ALIST);
IF TEMP^.ANATOM AND (TEMP^.NAME = 'NIL ')
THEN EVCON := EVCON(TAIL(CONDPAIRS))
ELSE EVCON := EVAL(HEAD(TAIL(HEAD(CONDPAIRS))),ALIST)
END;
BEGIN
IF E^.ANATOM THEN EVAL := LOOKUP(E,ALIST)
ELSE
BEGIN
CAROFE := HEAD(E);
IF CAROFE^.ANATOM
THEN
IF NOT CAROFE^.ISARESERVEDWORD
THEN
EVAL := EVAL(CONS(LOOKUP(CAROFE,ALIST),TAIL(E)),ALIST)
ELSE
CASE CAROFE^.RESSYM OF
LABELSYM, LAMBDASYM : ERROR(3);
QUOTESYM : EVAL := HEAD(TAIL(E));
ATOMSYM : EVAL := ATOM(EVAL(HEAD(TAIL(E)),ALIST));
EQSYM : EVAL := EQQ(EVAL(HEAD(TAIL(E)),ALIST),EVAL(HEAD(
TAIL(TAIL(E))),ALIST));
HEADSYM : EVAL := HEAD(EVAL(HEAD(TAIL(E)),ALIST));
TAILSYM : EVAL := TAIL(EVAL(HEAD(TAIL(E)),ALIST));
CONSSYM : EVAL := CONS(EVAL(HEAD(TAIL(E)),ALIST),
EVAL(HEAD(TAIL(TAIL(E))),ALIST));
CONDSYM : EVAL := EVCON(TAIL(E));
APPENDSYM : EVAL := APPEND(EVAL(HEAD(TAIL(E)),ALIST),EVAL(HEAD(
TAIL(TAIL(E))),ALIST))
END
ELSE
BEGIN
CAAROFE := HEAD(CAROFE);
IF CAAROFE^.ANATOM AND CAAROFE^.ISARESERVEDWORD
THEN
IF NOT (CAAROFE^.RESSYM IN [LABELSYM, LAMBDASYM])
THEN ERROR(12)
ELSE
CASE CAAROFE^.RESSYM OF
LABELSYM:
BEGIN
TEMP := CONS(CONS(HEAD(TAIL(CAROFE)),HEAD(TAIL(
TAIL(CAROFE)))),ALIST);
EVAL := EVAL(CONS(HEAD(TAIL(TAIL(CAROFE))),
TAIL(E)),TEMP)
END;
LAMBDASYM:
BEGIN
TEMP := BINDARGS(HEAD(TAIL(CAROFE)),TAIL(E));
EVAL := EVAL(HEAD(TAIL(TAIL(CAROFE))),TEMP)
END;
END
ELSE
EVAL := EVAL(CONS(EVAL(CAROFE,ALIST),TAIL(E)),ALIST)
END
END
END;
PROCEDURE INITIALIZE;
VAR I : INTEGER;
TEMP, NXT : SYMBEXPPTR;
BEGIN
ALREADYPEEKED := FALSE; READ(CH); NUMBEROFGCS := 0;
FREENODES := MAXNODE;
WITH NILNODE DO
BEGIN
ANATOM := TRUE; NEXT := NIL; NAME := 'NIL ';
STATUS := UNMARKED; ISARESERVEDWORD := FALSE
END;
WITH TNODE DO
BEGIN
ANATOM := TRUE; NEXT := NIL; NAME := 'T ';
STATUS := UNMARKED; ISARESERVEDWORD := FALSE
END;
FREELIST := NIL;
FOR I := 1 TO MAXNODE DO
BEGIN
NEW(NODELIST); NODELIST^.NEXT := FREELIST;
NODELIST^.HEAD := FREELIST; NODELIST^.STATUS := UNMARKED;
FREELIST := NODELIST
END;
RESWORDS[RHSYM] := 'REPLACEH ';
RESWORDS[RTSYM] := 'REPLACET ';
RESWORDS[HEADSYM] := 'CAR ';
RESWORDS[TAILSYM] := 'CDR ';
RESWORDS[COPYSYM] := 'COPY ';
RESWORDS[APPENDSYM] := 'APPEND ';
RESWORDS[CONCSYM] := 'CONC ';
RESWORDS[CONSSYM] := 'CONS ';
RESWORDS[EQSYM] := 'EQ ';
RESWORDS[QUOTESYM] := 'QUOTESYM ';
RESWORDS[ATOMSYM] := 'ATOM ';
RESWORDS[CONDSYM] := 'COND ';
RESWORDS[LABELSYM] := 'LABEL ';
RESWORDS[LAMBDASYM] := 'LAMBDA ';
POP(ALIST); ALIST^.ANATOM := FALSE; ALIST^.STATUS := UNMARKED;
POP(ALIST^.TAIL); NXT := ALIST^.TAIL^.NEXT;
POP(ALIST^.HEAD);
WITH ALIST^.HEAD^ DO
BEGIN
ANATOM := FALSE; STATUS := UNMARKED; POP(HEAD);
NXT := HEAD^.NEXT; HEAD^ := NILNODE; HEAD^.NEXT := NXT;
POP(TAIL); NXT := TAIL^.NEXT; TAIL^ := NILNODE;
TAIL^.NEXT := NXT
END;
POP(TEMP); TEMP^.ANATOM := FALSE; TEMP^.STATUS := UNMARKED;
TEMP^.TAIL := ALIST; ALIST := TEMP;
POP(ALIST^.HEAD);
WITH ALIST^.HEAD^ DO
BEGIN
ANATOM := FALSE; STATUS := UNMARKED; POP(HEAD);
NXT := HEAD^.NEXT; HEAD^ := TNODE; HEAD^.NEXT := NXT;
POP(TAIL); NXT := TAIL^.NEXT; TAIL^ := TNODE;
TAIL^.NEXT := NXT
END;
END;
BEGIN
IOTRAP(FALSE);
WRITELN(' * EVAL * '); INITIALIZE; NEXTSYM; READEXPR(PTR);
READLN; WRITELN;
WHILE NOT PTR^.ANATOM OR (PTR^.NAME <> 'FIN ') DO
BEGIN
WRITELN; WRITELN(' * VALUE * ');
PRINTEXPR(EVAL(PTR, ALIST));
101: WRITELN; WRITELN; IF EOF THEN ERROR(11);
PTR := NIL;
GARBAGEMAN; WRITELN; WRITELN;
WRITELN('EVAL'); NEXTSYM; READEXPR(PTR); READLN;
WRITELN
END;
102: WRITELN; WRITELN;
WRITELN('TOTAL NUMBER OF GARBAGE COLLECTIONS = ',NUMBEROFGCS:1,
'.');
WRITELN;
WRITELN('FREENODES LEFT UPON EXIT = ',FREENODES:1,'.');
WRITELN
END.